home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Tools⁄Additions / MacScheme20 / Mathlib / r-rat.scm < prev    next >
Encoding:
Text File  |  1989-04-27  |  2.2 KB  |  76 lines  |  [TEXT/????]
  1. ;;; $Header: r-rat.scm,v 1.3 88/02/10 00:25:25 GMT gjs Exp $
  2. ;;;; RATIONALIZE, HEURISTIC-ROUNDER
  3.  
  4. (if-mit (declare (usual-integrations)))
  5.  
  6. ;;; This file defines RATIONALIZE (Rrrrs) and uses it to make a heuristic
  7. ;;; number rounder.
  8.  
  9. (define rationalize-wallp false)
  10.  
  11. (define (rationalize x . optionals)
  12.   (define *default-maxden* 6e23)
  13.   (let ((epsilon
  14.      (if (not (null? optionals)) (car optionals) (* 10 *machine-epsilon*)))
  15.     (maxden
  16.      (if (and (not (null? optionals))
  17.           (not (null? (cdr optionals))))
  18.          (cadr optionals)
  19.          *default-maxden*)))
  20.     (define (rat1 x)
  21.       (let ((ix (truncate x)))
  22.     (let loop ((num ix) (den 1) (onum 1) (oden 0) (xx x) (a ix))
  23.       (if rationalize-wallp
  24.           (pp `((num= ,num) (den= ,den) (xx= ,xx))))                
  25.       (cond ((> den maxden) false)
  26.         ((and (not (= den 0))
  27.               (< (abs (/ (- x (/ num den)) x))
  28.              epsilon))
  29.          (cons num den))
  30.         (else
  31.          (let* ((y (/ 1 (- xx a)))
  32.             (iy (truncate y)))
  33.            (loop (+ (* iy num) onum)
  34.              (+ (* iy den) oden)
  35.              num
  36.              den
  37.              y
  38.              iy)))))))
  39.     (cond ((integer? x) x)
  40.       ((real? x)
  41.        (cond ((< (abs x) epsilon) 
  42.                   0)
  43.                  ((< x 0)
  44.                   (let ((a (rat1 (abs x))))
  45.                     (if a
  46.                         (cons (- (car a)) (cdr a))
  47.                         a)))
  48.                  (else (rat1 x))))
  49.       (else
  50.        (error "Can't rationalize" x)))))
  51.  
  52. ;;; Some processes, such as finding the roots of a polynomial, can
  53. ;;; benefit by heuristic rounding of results (to a nearby rational).
  54.  
  55. ;;; Heuristic rounding will occur to a rational within 
  56. (define heuristic-rounding-tolerance 1.0e-9)
  57. ;;; that is expressible with a denominator less than the 
  58. (define heuristic-rounding-denominator 100)
  59. ;;; if such a rational exists.
  60.  
  61. (define (heuristic-round-real x)
  62.   (let ((r (rationalize x
  63.                         heuristic-rounding-tolerance
  64.                         heuristic-rounding-denominator)))
  65.     (if r
  66.         (if (real? r)
  67.             r
  68.             (make-rational (car r) (cdr r)))
  69.         x)))
  70.  
  71. (define (heuristic-round-complex z)
  72.   (if (real? z)
  73.       (heuristic-round-real z)
  74.       (make-rectangular (heuristic-round-real (real-part z))
  75.                         (heuristic-round-real (imag-part z)))))
  76.